home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ShareWare OnLine 2
/
ShareWare OnLine Volume 2 (CMS Software)(1993).iso
/
bbsdoors
/
multi604.zip
/
MONOMAIN.ZIP
/
DUREE.PAS
next >
Wrap
Pascal/Delphi Source File
|
1992-08-28
|
4KB
|
176 lines
unit duree;
interface
uses dos;
function cstr(t:longint):string;
function timer:real;
function nsl:real;
function tch(t:string):string;
function time:string;
function days(mo,yr:integer):integer;
function date:string;
function leapyear(yr:integer):boolean;
function daynum(dt:string):integer;
function daycount(mo,yr:integer):integer;
function dat:string;
function ctim(rl:real):string;
procedure calculheure(var heure,minute,seconde:integer);
implementation
var timeon,timeleft:real;
comport:byte;
function cstr(t:longint):string;
var cu:string;
begin
str(t,cu); cstr:=cu;
end;
function timer:real;
var reg:registers;
ho1,mi1,s3,t1:real;
begin
reg.ax:=44*256;
msdos(dos.registers(reg));
ho1:=(reg.cx div 256);
mi1:=(reg.cx mod 256);
s3:=(reg.dx div 256);
t1:=(reg.dx mod 256);
timer:=ho1*3600+mi1*60+s3+t1/100;
end;
function nsl:real;
begin
if timer<timeon then timeon:=timeon-24.0*3600.0;
nsl:=timeleft-(timer-timeon);
end;
function time:string;
var reg:registers;
zt:integer;
ho1,mi1,se:string[4];
begin
reg.ax:=$2c00; intr($21,dos.registers(reg));
zt:=reg.cx shr 8; ho1:=cstr(zt);
zt:=reg.cx mod 256; str(zt,mi1); str(reg.dx shr 8,se);
time:=tch(ho1)+':'+tch(mi1)+':'+tch(se);
end;
function date:string;
var reg:registers;
mi1,du,yx:string[4];
begin
reg.ax:=$2a00; msdos(dos.registers(reg)); str(reg.cx,yx); str(reg.dx mod 256,du);
str(reg.dx shr 8,mi1);
date:=tch(mi1)+'/'+tch(du)+'/'+tch(yx);
end;
function value(t:string):integer;
var n,n1:integer;
begin
val(t,n,n1);
if n1<>0 then begin
t:=copy(t,1,n1-1);
val(t,n,n1)
end;
value:=n;
if t='' then value:=0;
end;
procedure calculheure(var heure,minute,seconde:integer);
begin
heure:=value(copy(time,1,2));
minute:=value(copy(time,4,2));
seconde:=value(copy(time,7,2));
end;
function leapyear(yr:integer):boolean;
begin
leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0));
end;
function days(mo,yr:integer):integer;
var du:integer;
begin
du:=value(copy('312831303130313130313031 ',1+(mo-1)*2,2));
if (mo=2) and leapyear(yr) then du:=du+1;
days:=du;
end;
function daycount(mo,yr:integer):integer;
var mi1,tu:integer;
begin
tu:=0;
for mi1:=1 to (mo-1) do tu:=tu+days(mi1,yr);
daycount:=tu;
end;
function tch(t:string):string;
begin
if length(t)>2 then t:=copy(t,length(t)-1,2) else
if length(t)=1 then t:='0'+t;
tch:=t;
end;
function daynum(dt:string):integer;
var du,mi1,yx,tu,cu:integer;
begin
tu:=0;
mi1:= value(copy(dt,1,2));
du:=value(copy(dt,4,2));
yx:=value(copy(dt,7,2))+1900;
for cu:=1985 to yx-1 do
if leapyear(cu) then tu:=tu+366 else tu:=tu+365;
tu:=tu+daycount(mi1,yx)+(du-1);
daynum:=tu;
if yx<1985 then daynum:=0;
end;
function dat:string;
var ap,xy,yx:string; t:integer;
begin
case daynum(date) mod 7 of
0:xy:='Tue';
1:xy:='Wed';
2:xy:='Thu';
3:xy:='Fri';
4:xy:='Sat';
5:xy:='Sun';
6:xy:='Mon';
end;
case value(copy(date,1,2)) of
1:yx:='Jan';
2:yx:='Feb';
3:yx:='Mar';
4:yx:='Apr';
5:yx:='May';
6:yx:='Jun';
7:yx:='Jul';
8:yx:='Aug';
9:yx:='Sep';
10:yx:='Oct';
11:yx:='Nov';
12:yx:='Dec';
end;
xy:=xy+' '+yx+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2)));
yx:=time; t:=value(copy(yx,1,2));
if t>11 then ap:='pm' else ap:='am';
if t>12 then t:=t-12;
if t=0 then t:=12;
dat:=cstr(t)+copy(yx,3,3)+' '+ap+' '+xy;
end;
function ctim(rl:real):string;
var ho1,mi1,se:string;
begin
se:=tch(cstr(trunc(rl-int(rl/60.0)*60.0)));
mi1:=tch(cstr(trunc(int(rl/60.0)-int(rl/3600.0)*60.0)));
ho1:=cstr(trunc(rl/3600.0));
if length(ho1)=1 then ho1:='0'+ho1;
ctim:=ho1+':'+mi1+':'+se;
end;
end.